home *** CD-ROM | disk | FTP | other *** search
/ Reverse Code Engineering RCE CD +sandman 2000 / ReverseCodeEngineeringRceCdsandman2000.iso / RCE / Tools / Turbo Pascal V7 / SOURCE.ZIP / STDDLG.PAS < prev    next >
Pascal/Delphi Source File  |  1992-11-03  |  37KB  |  1,460 lines
  1.  
  2. {*******************************************************}
  3. {                                                       }
  4. {       Turbo Pascal Version 7.0                        }
  5. {       Turbo Vision Unit                               }
  6. {                                                       }
  7. {       Copyright (c) 1992 Borland International        }
  8. {                                                       }
  9. {*******************************************************}
  10.  
  11. unit StdDlg;
  12.  
  13. {$O+,F+,V-,X+,I-,S-}
  14.  
  15. interface
  16.  
  17. uses Objects, Drivers, Views, Dialogs, Dos;
  18.  
  19. const
  20.  
  21. { Commands }
  22.  
  23.   cmFileOpen    = 800;   { Returned from TFileDialog when Open pressed }
  24.   cmFileReplace = 801;   { Returned from TFileDialog when Replace pressed }
  25.   cmFileClear   = 802;   { Returned from TFileDialog when Clear pressed }
  26.   cmFileInit    = 803;   { Used by TFileDialog internally }
  27.   cmChDir       = 804;   { Used by TChDirDialog internally }
  28.   cmRevert      = 805;   { Used by TChDirDialog internally }
  29.  
  30. { Messages }
  31.  
  32.   cmFileFocused = 806;    { A new file was focused in the TFileList }
  33.   cmFileDoubleClicked     { A file was selected in the TFileList }
  34.                 = 807;
  35.  
  36. type
  37.  
  38.   { TSearchRec }
  39.  
  40.   {  Record used to store directory information by TFileDialog }
  41.  
  42.   TSearchRec = record
  43.     Attr: Byte;
  44.     Time: Longint;
  45.     Size: Longint;
  46.     Name: string[12];
  47.   end;
  48.  
  49. type
  50.  
  51.   { TFileInputLine is a special input line that is used by      }
  52.   { TFileDialog that will update its contents in response to a  }
  53.   { cmFileFocused command from a TFileList.                     }
  54.  
  55.   PFileInputLine = ^TFileInputLine;
  56.   TFileInputLine = object(TInputLine)
  57.     constructor Init(var Bounds: TRect; AMaxLen: Integer);
  58.     procedure HandleEvent(var Event: TEvent); virtual;
  59.   end;
  60.  
  61.   { TFileCollection is a collection of TSearchRec's.            }
  62.  
  63.   PFileCollection = ^TFileCollection;
  64.   TFileCollection = object(TSortedCollection)
  65.     function Compare(Key1, Key2: Pointer): Integer; virtual;
  66.     procedure FreeItem(Item: Pointer); virtual;
  67.     function GetItem(var S: TStream): Pointer; virtual;
  68.     procedure PutItem(var S: TStream; Item: Pointer); virtual;
  69.   end;
  70.  
  71.   { TSortedListBox is a TListBox that assumes it has a          }
  72.   { TStoredCollection instead of just a TCollection.  It will   }
  73.   { perform an incremental search on the contents.              }
  74.  
  75.   PSortedListBox = ^TSortedListBox;
  76.   TSortedListBox = object(TListBox)
  77.     SearchPos: Word;
  78.     ShiftState: Byte;
  79.     constructor Init(var Bounds: TRect; ANumCols: Word;
  80.       AScrollBar: PScrollBar);
  81.     procedure HandleEvent(var Event: TEvent); virtual;
  82.     function GetKey(var S: String): Pointer; virtual;
  83.     procedure NewList(AList: PCollection); virtual;
  84.   end;
  85.  
  86.   { TFileList is a TSortedList box that assumes it contains     }
  87.   { a TFileCollection as its collection.  It also communicates  }
  88.   { through broadcast messages to TFileInput and TInfoPane      }
  89.   { what file is currently selected.                            }
  90.  
  91.   PFileList = ^TFileList;
  92.   TFileList = object(TSortedListBox)
  93.     constructor Init(var Bounds: TRect; AScrollBar: PScrollBar);
  94.     destructor Done; virtual;
  95.     function DataSize: Word; virtual;
  96.     procedure FocusItem(Item: Integer); virtual;
  97.     procedure GetData(var Rec); virtual;
  98.     function GetText(Item: Integer; MaxLen: Integer): String; virtual;
  99.     function GetKey(var S: String): Pointer; virtual;
  100.     procedure HandleEvent(var Event: TEvent); virtual;
  101.     procedure ReadDirectory(AWildCard: PathStr);
  102.     procedure SetData(var Rec); virtual;
  103.   end;
  104.  
  105.   { TFileInfoPane is a TView that displays the information      }
  106.   { about the currently selected file in the TFileList          }
  107.   { of a TFileDialog.                                           }
  108.  
  109.   PFileInfoPane = ^TFileInfoPane;
  110.   TFileInfoPane = object(TView)
  111.     S: TSearchRec;
  112.     constructor Init(var Bounds: TRect);
  113.     procedure Draw; virtual;
  114.     function GetPalette: PPalette; virtual;
  115.     procedure HandleEvent(var Event: TEvent); virtual;
  116.   end;
  117.  
  118.   { TFileDialog is a standard file name input dialog            }
  119.  
  120.   TWildStr = PathStr;
  121.  
  122. const
  123.   fdOkButton      = $0001;      { Put an OK button in the dialog }
  124.   fdOpenButton    = $0002;      { Put an Open button in the dialog }
  125.   fdReplaceButton = $0004;      { Put a Replace button in the dialog }
  126.   fdClearButton   = $0008;      { Put a Clear button in the dialog }
  127.   fdHelpButton    = $0010;      { Put a Help button in the dialog }
  128.   fdNoLoadDir     = $0100;      { Do not load the current directory }
  129.                                 { contents into the dialog at Init. }
  130.                                 { This means you intend to change the }
  131.                                 { WildCard by using SetData or store }
  132.                                 { the dialog on a stream. }
  133.  
  134. type
  135.  
  136.   PFileDialog = ^TFileDialog;
  137.   TFileDialog = object(TDialog)
  138.     FileName: PFileInputLine;
  139.     FileList: PFileList;
  140.     WildCard: TWildStr;
  141.     Directory: PString;
  142.     constructor Init(AWildCard: TWildStr; const ATitle,
  143.       InputName: String; AOptions: Word; HistoryId: Byte);
  144.     constructor Load(var S: TStream);
  145.     destructor Done; virtual;
  146.     procedure GetData(var Rec); virtual;
  147.     procedure GetFileName(var S: PathStr);
  148.     procedure HandleEvent(var Event: TEvent); virtual;
  149.     procedure SetData(var Rec); virtual;
  150.     procedure Store(var S: TStream);
  151.     function Valid(Command: Word): Boolean; virtual;
  152.   private
  153.     procedure ReadDirectory;
  154.   end;
  155.  
  156.   { TDirEntry }
  157.  
  158.   PDirEntry = ^TDirEntry;
  159.   TDirEntry = record
  160.     DisplayText: PString;
  161.     Directory: PString;
  162.   end;
  163.  
  164.   { TDirCollection is a collection of TDirEntry's used by       }
  165.   { TDirListBox.                                                }
  166.  
  167.   PDirCollection = ^TDirCollection;
  168.   TDirCollection = object(TCollection)
  169.     function GetItem(var S: TStream): Pointer; virtual;
  170.     procedure FreeItem(Item: Pointer); virtual;
  171.     procedure PutItem(var S: TStream; Item: Pointer); virtual;
  172.   end;
  173.  
  174.   { TDirListBox displays a tree of directories for use in the }
  175.   { TChDirDialog.                                               }
  176.  
  177.   PDirListBox = ^TDirListBox;
  178.   TDirListBox = object(TListBox)
  179.     Dir: DirStr;
  180.     Cur: Word;
  181.     constructor Init(var Bounds: TRect; AScrollBar: PScrollBar);
  182.     destructor Done; virtual;
  183.     function GetText(Item: Integer; MaxLen: Integer): String; virtual;
  184.     procedure HandleEvent(var Event: TEvent); virtual;
  185.     function IsSelected(Item: Integer): Boolean; virtual;
  186.     procedure NewDirectory(var ADir: DirStr);
  187.     procedure SetState(AState: Word; Enable: Boolean); virtual;
  188.   end;
  189.  
  190.   { TChDirDialog is a standard change directory dialog.         }
  191.  
  192. const
  193.   cdNormal     = $0000; { Option to use dialog immediately }
  194.   cdNoLoadDir  = $0001; { Option to init the dialog to store on a stream }
  195.   cdHelpButton = $0002; { Put a help button in the dialog }
  196.  
  197. type
  198.  
  199.   PChDirDialog = ^TChDirDialog;
  200.   TChDirDialog = object(TDialog)
  201.     DirInput: PInputLine;
  202.     DirList: PDirListBox;
  203.     OkButton: PButton;
  204.     ChDirButton: PButton;
  205.     constructor Init(AOptions: Word; HistoryId: Word);
  206.     constructor Load(var S: TStream);
  207.     function DataSize: Word; virtual;
  208.     procedure GetData(var Rec); virtual;
  209.     procedure HandleEvent(var Event: TEvent); virtual;
  210.     procedure SetData(var Rec); virtual;
  211.     procedure Store(var S: TStream);
  212.     function Valid(Command: Word): Boolean; virtual;
  213.   private
  214.     procedure SetUpDialog;
  215.   end;
  216.  
  217. const
  218.  
  219.   CInfoPane = #30;
  220.  
  221.   { TStream registration records }
  222.  
  223. const
  224.   RFileInputLine: TStreamRec = (
  225.      ObjType: 60;
  226.      VmtLink: Ofs(TypeOf(TFileInputLine)^);
  227.      Load:    @TFileInputLine.Load;
  228.      Store:   @TFileInputLine.Store
  229.   );
  230.  
  231. const
  232.   RFileCollection: TStreamRec = (
  233.      ObjType: 61;
  234.      VmtLink: Ofs(TypeOf(TFileCollection)^);
  235.      Load:    @TFileCollection.Load;
  236.      Store:   @TFileCollection.Store
  237.   );
  238.  
  239. const
  240.   RFileList: TStreamRec = (
  241.      ObjType: 62;
  242.      VmtLink: Ofs(TypeOf(TFileList)^);
  243.      Load:    @TFileList.Load;
  244.      Store:   @TFileList.Store
  245.   );
  246.  
  247. const
  248.   RFileInfoPane: TStreamRec = (
  249.      ObjType: 63;
  250.      VmtLink: Ofs(TypeOf(TFileInfoPane)^);
  251.      Load:    @TFileInfoPane.Load;
  252.      Store:   @TFileInfoPane.Store
  253.   );
  254.  
  255. const
  256.   RFileDialog: TStreamRec = (
  257.      ObjType: 64;
  258.      VmtLink: Ofs(TypeOf(TFileDialog)^);
  259.      Load:    @TFileDialog.Load;
  260.      Store:   @TFileDialog.Store
  261.   );
  262.  
  263. const
  264.   RDirCollection: TStreamRec = (
  265.      ObjType: 65;
  266.      VmtLink: Ofs(TypeOf(TDirCollection)^);
  267.      Load:    @TDirCollection.Load;
  268.      Store:   @TDirCollection.Store
  269.   );
  270.  
  271. const
  272.   RDirListBox: TStreamRec = (
  273.      ObjType: 66;
  274.      VmtLink: Ofs(TypeOf(TDirListBox)^);
  275.      Load:    @TDirListBox.Load;
  276.      Store:   @TDirListBox.Store
  277.   );
  278.  
  279. const
  280.   RChDirDialog: TStreamRec = (
  281.      ObjType: 67;
  282.      VmtLink: Ofs(TypeOf(TChDirDialog)^);
  283.      Load:    @TChDirDialog.Load;
  284.      Store:   @TChDirDialog.Store
  285.   );
  286.  
  287. const
  288.   RSortedListBox: TStreamRec = (
  289.      ObjType: 68;
  290.      VmtLink: Ofs(TypeOf(TSortedListBox)^);
  291.      Load:    @TSortedListBox.Load;
  292.      Store:   @TSortedListBox.Store
  293.   );
  294.  
  295. procedure RegisterStdDlg;
  296.  
  297. implementation
  298.  
  299. uses App, Memory, HistList, MsgBox;
  300.  
  301. function DriveValid(Drive: Char): Boolean; near; assembler;
  302. asm
  303.     MOV    AH,19H          { Save the current drive in BL }
  304.         INT    21H
  305.         MOV    BL,AL
  306.      MOV    DL,Drive    { Select the given drive }
  307.         SUB    DL,'A'
  308.         MOV    AH,0EH
  309.         INT    21H
  310.         MOV    AH,19H        { Retrieve what DOS thinks is current }
  311.         INT    21H
  312.         MOV    CX,0        { Assume false }
  313.         CMP    AL,DL        { Is the current drive the given drive? }
  314.     JNE    @@1
  315.         MOV    CX,1        { It is, so the drive is valid }
  316.     MOV    DL,BL        { Restore the old drive }
  317.         MOV    AH,0EH
  318.         INT    21H
  319. @@1:    XCHG    AX,CX        { Put the return value into AX }
  320. end;
  321.  
  322. function PathValid(var Path: PathStr): Boolean;
  323. var
  324.   ExpPath: PathStr;
  325.   SR: SearchRec;
  326. begin
  327.   ExpPath := FExpand(Path);
  328.   if Length(ExpPath) <= 3 then PathValid := DriveValid(ExpPath[1])
  329.   else
  330.   begin
  331.     if ExpPath[Length(ExpPath)] = '\' then Dec(ExpPath[0]);
  332.     FindFirst(ExpPath, Directory, SR);
  333.     PathValid := (DosError = 0) and (SR.Attr and Directory <> 0);
  334.   end;
  335. end;
  336.  
  337. function ValidFileName(var FileName: PathStr): Boolean;
  338. const
  339.   IllegalChars = ';,=+<>|"[] \';
  340. var
  341.   Dir: DirStr;
  342.   Name: NameStr;
  343.   Ext: ExtStr;
  344.  
  345. { Contains returns true if S1 contains any characters in S2 }
  346. function Contains(S1, S2: String): Boolean; near; assembler;
  347. asm
  348.     PUSH    DS
  349.         CLD
  350.         LDS    SI,S1
  351.         LES    DI,S2
  352.         MOV    DX,DI
  353.         XOR    AH,AH
  354.         LODSB
  355.         MOV    BX,AX
  356.         OR      BX,BX
  357.         JZ      @@2
  358.         MOV    AL,ES:[DI]
  359.         XCHG    AX,CX
  360. @@1:    PUSH    CX
  361.     MOV    DI,DX
  362.     LODSB
  363.         REPNE    SCASB
  364.         POP    CX
  365.         JE    @@3
  366.     DEC    BX
  367.         JNZ    @@1
  368. @@2:    XOR    AL,AL
  369.     JMP    @@4
  370. @@3:    MOV    AL,1
  371. @@4:    POP    DS
  372. end;
  373.  
  374. begin
  375.   ValidFileName := True;
  376.   FSplit(FileName, Dir, Name, Ext);
  377.   if not ((Dir = '') or PathValid(Dir)) or Contains(Name, IllegalChars) or
  378.     Contains(Dir, IllegalChars) then ValidFileName := False;
  379. end;
  380.  
  381. function GetCurDir: DirStr;
  382. var
  383.   CurDir: DirStr;
  384. begin
  385.   GetDir(0, CurDir);
  386.   if Length(CurDir) > 3 then
  387.   begin
  388.     Inc(CurDir[0]);
  389.     CurDir[Length(CurDir)] := '\';
  390.   end;
  391.   GetCurDir := CurDir;
  392. end;
  393.  
  394. type
  395.   PSearchRec = ^TSearchRec;
  396.  
  397. function IsWild(const S: String): Boolean;
  398. begin
  399.   IsWild := (Pos('?',S) > 0) or (Pos('*',S) > 0);
  400. end;
  401.  
  402. function IsDir(const S: String): Boolean;
  403. var
  404.   SR: SearchRec;
  405. begin
  406.   FindFirst(S, Directory, SR);
  407.   if DosError = 0 then
  408.     IsDir := SR.Attr and Directory <> 0
  409.   else IsDir := False;
  410. end;
  411.  
  412. { TFileInputLine }
  413.  
  414. constructor TFileInputLine.Init(var Bounds: TRect; AMaxLen: Integer);
  415. begin
  416.   TInputLine.Init(Bounds, AMaxLen);
  417.   EventMask := EventMask or evBroadcast;
  418. end;
  419.  
  420. procedure TFileInputLine.HandleEvent(var Event: TEvent);
  421. var
  422.   Dir: DirStr;
  423.   Name: NameStr;
  424.   Ext: ExtStr;
  425. begin
  426.   TInputLine.HandleEvent(Event);
  427.   if (Event.What = evBroadcast) and (Event.Command = cmFileFocused) and
  428.     (State and sfSelected = 0) then
  429.   begin
  430.      if PSearchRec(Event.InfoPtr)^.Attr and Directory <> 0 then
  431.         Data^ := PSearchRec(Event.InfoPtr)^.Name + '\'+
  432.           PFileDialog(Owner)^.WildCard
  433.      else Data^ := PSearchRec(Event.InfoPtr)^.Name;
  434.      DrawView;
  435.   end;
  436. end;
  437.  
  438. { TFileCollection }
  439.  
  440. function TFileCollection.Compare(Key1, Key2: Pointer): Integer;
  441. begin
  442.   if PSearchRec(Key1)^.Name = PSearchRec(Key2)^.Name then Compare := 0
  443.   else if PSearchRec(Key1)^.Name = '..' then Compare := 1
  444.   else if PSearchRec(Key2)^.Name = '..' then Compare := -1
  445.   else if (PSearchRec(Key1)^.Attr and Directory <> 0) and
  446.      (PSearchRec(Key2)^.Attr and Directory = 0) then Compare := 1
  447.   else if (PSearchRec(Key2)^.Attr and Directory <> 0) and
  448.      (PSearchRec(Key1)^.Attr and Directory = 0) then Compare := -1
  449.   else if PSearchRec(Key1)^.Name > PSearchRec(Key2)^.Name then
  450.     Compare := 1
  451.   else Compare := -1;
  452. end;
  453.  
  454. procedure TFileCollection.FreeItem(Item: Pointer);
  455. begin
  456.   Dispose(PSearchRec(Item));
  457. end;
  458.  
  459. function TFileCollection.GetItem(var S: TStream): Pointer;
  460. var
  461.   Item: PSearchRec;
  462. begin
  463.   New(Item);
  464.   S.Read(Item^, SizeOf(TSearchRec));
  465.   GetItem := Item;
  466. end;
  467.  
  468. procedure TFileCollection.PutItem(var S: TStream; Item: Pointer);
  469. begin
  470.   S.Write(Item^, SizeOf(TSearchRec));
  471. end;
  472.  
  473. { TSortedListBox }
  474.  
  475. constructor TSortedListBox.Init(var Bounds: TRect; ANumCols: Word;
  476.   AScrollBar: PScrollBar);
  477. begin
  478.   TListBox.Init(Bounds, ANumCols, AScrollBar);
  479.   SearchPos := 0;
  480.   ShowCursor;
  481.   SetCursor(1,0);
  482. end;
  483.  
  484. procedure TSortedListBox.HandleEvent(var Event: TEvent);
  485. var
  486.   CurString, NewString: String;
  487.   K: Pointer;
  488.   Value, OldPos, OldValue: Integer;
  489.   T: Boolean;
  490.  
  491. function Equal(const S1, S2: String; Count: Word): Boolean;
  492. var
  493.   I: Word;
  494. begin
  495.   Equal := False;
  496.   if (Length(S1) < Count) or (Length(S2) < Count) then Exit;
  497.   for I := 1 to Count do
  498.     if UpCase(S1[I]) <> UpCase(S2[I]) then Exit;
  499.   Equal := True;
  500. end;
  501.  
  502. begin
  503.   OldValue := Focused;
  504.   TListBox.HandleEvent(Event);
  505.   if OldValue <> Focused then SearchPos := 0;
  506.   if Event.What = evKeyDown then
  507.   begin
  508.     if Event.CharCode <> #0 then
  509.     begin
  510.       Value := Focused;
  511.       if Value < Range then CurString := GetText(Value, 255)
  512.       else CurString := '';
  513.       OldPos := SearchPos;
  514.       if Event.KeyCode = kbBack then
  515.       begin
  516.         if SearchPos = 0 then Exit;
  517.         Dec(SearchPos);
  518.         if SearchPos = 0 then ShiftState := GetShiftState;
  519.         CurString[0] := Char(SearchPos);
  520.       end
  521.       else if (Event.CharCode = '.') then SearchPos := Pos('.',CurString)
  522.       else
  523.       begin
  524.         Inc(SearchPos);
  525.         if SearchPos = 1 then ShiftState := GetShiftState;
  526.         CurString[0] := Char(SearchPos);
  527.         CurString[SearchPos] := Event.CharCode;
  528.       end;
  529.       K := GetKey(CurString);
  530.       T := PSortedCollection(List)^.Search(K, Value);
  531.       if Value < Range then
  532.       begin
  533.         if Value < Range then NewString := GetText(Value, 255)
  534.         else NewString := '';
  535.         if Equal(NewString, CurString, SearchPos) then
  536.         begin
  537.           if Value <> OldValue then
  538.           begin
  539.             FocusItem(Value);
  540.             { Assumes ListControl will set the cursor to the first character }
  541.             { of the sfFocused item }
  542.             SetCursor(Cursor.X+SearchPos, Cursor.Y);
  543.           end
  544.           else SetCursor(Cursor.X+(SearchPos-OldPos), Cursor.Y);
  545.         end
  546.         else SearchPos := OldPos;
  547.       end
  548.       else SearchPos := OldPos;
  549.       if (SearchPos <> OldPos) or (Event.CharCode in ['A'..'Z','a'..'z']) then
  550.         ClearEvent(Event);
  551.     end;
  552.   end;
  553. end;
  554.  
  555. function TSortedListBox.GetKey(var S: String): Pointer;
  556. begin
  557.   GetKey := @S;
  558. end;
  559.  
  560. procedure TSortedListBox.NewList(AList: PCollection);
  561. begin
  562.   TListBox.NewList(AList);
  563.   SearchPos := 0;
  564. end;
  565.  
  566. { TFileList }
  567.  
  568. constructor TFileList.Init(var Bounds: TRect; AScrollBar: PScrollBar);
  569. begin
  570.   TSortedListBox.Init(Bounds, 2, AScrollBar);
  571. end;
  572.  
  573. destructor TFileList.Done;
  574. begin
  575.   if List <> nil then Dispose(List, Done);
  576.   TListBox.Done;
  577. end;
  578.  
  579. function TFileList.DataSize: Word;
  580. begin
  581.   DataSize := 0;
  582. end;
  583.  
  584. procedure TFileList.FocusItem(Item: Integer);
  585. begin
  586.   TSortedListBox.FocusItem(Item);
  587.   Message(Owner, evBroadcast, cmFileFocused, List^.At(Item));
  588. end;
  589.  
  590. procedure TFileList.GetData(var Rec);
  591. begin
  592. end;
  593.  
  594. function TFileList.GetKey(var S: String): Pointer;
  595. const
  596.   SR: TSearchRec = ();
  597.  
  598. procedure UpStr(var S: String);
  599. var
  600.   I: Integer;
  601. begin
  602.   for I := 1 to Length(S) do S[I] := UpCase(S[I]);
  603. end;
  604.  
  605. begin
  606.   if (ShiftState and $03 <> 0) or ((S <> '') and (S[1]='.')) then
  607.     SR.Attr := Directory
  608.   else SR.Attr := 0;
  609.   SR.Name := S;
  610.   UpStr(SR.Name);
  611.   GetKey := @SR;
  612. end;
  613.  
  614. function TFileList.GetText(Item: Integer; MaxLen: Integer): String;
  615. var
  616.   S: String;
  617.   SR: PSearchRec;
  618. begin
  619.   SR := PSearchRec(List^.At(Item));
  620.   S := SR^.Name;
  621.   if SR^.Attr and Directory <> 0 then
  622.   begin
  623.     S[Length(S)+1] := '\';
  624.     Inc(S[0]);
  625.   end;
  626.   GetText := S;
  627. end;
  628.  
  629. procedure TFileList.HandleEvent(var Event: TEvent);
  630. begin
  631.   if (Event.What = evMouseDown) and (Event.Double) then
  632.   begin
  633.     Event.What := evCommand;
  634.     Event.Command := cmOK;
  635.     PutEvent(Event);
  636.     ClearEvent(Event);
  637.   end
  638.   else TSortedListBox.HandleEvent(Event);
  639. end;
  640.  
  641. procedure TFileList.ReadDirectory(AWildCard: PathStr);
  642. const
  643.   FindAttr = ReadOnly + Archive;
  644.   AllFiles = '*.*';
  645.   PrevDir  = '..';
  646. var
  647.   S: SearchRec;
  648.   P: PSearchRec;
  649.   FileList: PFileCollection;
  650.   NumFiles: Word;
  651.   CurPath: PathStr;
  652.   Dir: DirStr;
  653.   Name: NameStr;
  654.   Ext: ExtStr;
  655.   Event: TEvent;
  656.   Tmp: PathStr;
  657.   Flag: Integer;
  658. begin
  659.   NumFiles := 0;
  660.   AWildCard := FExpand(AWildCard);
  661.   FSplit(AWildCard, Dir, Name, Ext);
  662.   FileList := New(PFileCollection, Init(5, 5));
  663.   FindFirst(AWildCard, FindAttr, S);
  664.   P := @P;
  665.   while (P <> nil) and (DosError = 0) do
  666.   begin
  667.     if (S.Attr and Directory = 0) then
  668.     begin
  669.       P := MemAlloc(SizeOf(P^));
  670.       if P <> nil then
  671.       begin
  672.         Move(S.Attr, P^, SizeOf(P^));
  673.         FileList^.Insert(P);
  674.       end;
  675.     end;
  676.     FindNext(S);
  677.   end;
  678.   Tmp := Dir + AllFiles;
  679.   FindFirst(Tmp, Directory, S);
  680.   while (P <> nil) and (DosError = 0) do
  681.   begin
  682.     if (S.Attr and Directory <> 0) and (S.Name[1] <> '.') then
  683.     begin
  684.       P := MemAlloc(SizeOf(P^));
  685.       if P <> nil then
  686.       begin
  687.         Move(S.Attr, P^, SizeOf(P^));
  688.         FileList^.Insert(PObject(P));
  689.       end;
  690.     end;
  691.     FindNext(S);
  692.   end;
  693.   if Length(Dir) > 4 then
  694.   begin
  695.     P := MemAlloc(SizeOf(P^));
  696.     if P <> nil then
  697.     begin
  698.       FindFirst(Tmp, Directory, S);
  699.       FindNext(S);
  700.       if (DosError = 0) and (S.Name = PrevDir) then
  701.         Move(S.Attr, P^, SizeOf(P^))
  702.       else
  703.       begin
  704.         P^.Name := PrevDir;
  705.         P^.Size := 0;
  706.         P^.Time := $210000;
  707.         P^.Attr := Directory;
  708.       end;
  709.       FileList^.Insert(PObject(P));
  710.     end;
  711.   end;
  712.   if P = nil then MessageBox('Too many files.', nil, mfOkButton + mfWarning);
  713.   NewList(FileList);
  714.   if List^.Count > 0 then
  715.   begin
  716.     Event.What := evBroadcast;
  717.     Event.Command := cmFileFocused;
  718.     Event.InfoPtr := List^.At(0);
  719.     Owner^.HandleEvent(Event);
  720.   end;
  721. end;
  722.  
  723. procedure TFileList.SetData(var Rec);
  724. begin
  725.   with PFileDialog(Owner)^ do
  726.     Self.ReadDirectory(Directory^ + WildCard);
  727. end;
  728.  
  729. { TFileInfoPane }
  730.  
  731. constructor TFileInfoPane.Init(var Bounds: TRect);
  732. begin
  733.   TView.Init(Bounds);
  734.   EventMask := EventMask or evBroadcast;
  735. end;
  736.  
  737. procedure TFileInfoPane.Draw;
  738. var
  739.   B: TDrawBuffer;
  740.   D: String[9];
  741.   M: String[3];
  742.   PM: Boolean;
  743.   Color: Word;
  744.   Time: DateTime;
  745.   Path: PathStr;
  746.   FmtId: String;
  747.   Params: array[0..7] of LongInt;
  748.   Str: String[80];
  749. const
  750.   sDirectoryLine = ' %-12s %-9s %3s %2d, %4d  %2d:%02d%cm';
  751.   sFileLine      = ' %-12s %-9d %3s %2d, %4d  %2d:%02d%cm';
  752.   Month: array[1..12] of String[3] = 
  753.     ('Jan','Feb','Mar','Apr','May','Jun',
  754.      'Jul','Aug','Sep','Oct','Nov','Dec');
  755. begin
  756.   { Display path }
  757.   Path := FExpand(PFileDialog(Owner)^.Directory^+PFileDialog(Owner)^.WildCard);
  758.   Color := GetColor($01);
  759.   MoveChar(B, ' ', Color, Size.X);
  760.   MoveStr(B[1], Path, Color);
  761.   WriteLine(0, 0, Size.X, 1, B);
  762.  
  763.   { Display file }
  764.   Params[0] := LongInt(@S.Name);
  765.   MoveChar(B, ' ', Color, Size.X);
  766.   Params[0] := LongInt(@S.Name);
  767.   if S.Attr and Directory <> 0 then
  768.   begin
  769.     FmtId := sDirectoryLine;
  770.     D := 'Directory';
  771.     Params[1] := LongInt(@D);
  772.   end else
  773.   begin
  774.     FmtId := sFileLine;
  775.     Params[1] := S.Size;
  776.   end;
  777.   UnpackTime(S.Time, Time);
  778.   M := Month[Time.Month];
  779.   Params[2] := LongInt(@M);
  780.   Params[3] := Time.Day;
  781.   Params[4] := Time.Year;
  782.   PM := Time.Hour >= 12;
  783.   Time.Hour := Time.Hour mod 12;
  784.   if Time.Hour = 0 then Time.Hour := 12;
  785.   Params[5] := Time.Hour;
  786.   Params[6] := Time.Min;
  787.   if PM then Params[7] := Byte('p')
  788.   else Params[7] := Byte('a');
  789.   FormatStr(Str, FmtId, Params);
  790.   MoveStr(B, Str, Color);
  791.   WriteLine(0, 1, Size.X, 1, B);
  792.  
  793.   { Fill in rest of rectangle }
  794.   MoveChar(B, ' ', Color, Size.X);
  795.   WriteLine(0, 2, Size.X, Size.Y-2, B);
  796. end;
  797.  
  798. function TFileInfoPane.GetPalette: PPalette;
  799. const
  800.   P: String[Length(CInfoPane)] = CInfoPane;
  801. begin
  802.   GetPalette := @P;
  803. end;
  804.  
  805. procedure TFileInfoPane.HandleEvent(var Event: TEvent);
  806. begin
  807.   TView.HandleEvent(Event);
  808.   if (Event.What = evBroadcast) and (Event.Command = cmFileFocused) then
  809.   begin
  810.     S := PSearchRec(Event.InfoPtr)^;
  811.     DrawView;
  812.   end;
  813. end;
  814.  
  815. { TFileDialog }
  816.  
  817. constructor TFileDialog.Init(AWildCard: TWildStr; const ATitle,
  818.   InputName: String; AOptions: Word; HistoryId: Byte);
  819. var
  820.   Control: PView;
  821.   R: TRect;
  822.   Opt: Word;
  823. begin
  824.   R.Assign(15,1,64,20);
  825.   TDialog.Init(R, ATitle);
  826.   Options := Options or ofCentered;
  827.   WildCard := AWildCard;
  828.  
  829.   R.Assign(3,3,31,4);
  830.   FileName := New(PFileInputLine, Init(R, 79));
  831.   FileName^.Data^ := WildCard;
  832.   Insert(FileName);
  833.   R.Assign(2,2,3+CStrLen(InputName),3);
  834.   Control := New(PLabel, Init(R, InputName, FileName));
  835.   Insert(Control);
  836.   R.Assign(31,3,34,4);
  837.   Control := New(PHistory, Init(R, FileName, HistoryId));
  838.   Insert(Control);
  839.  
  840.   R.Assign(3,14,34,15);
  841.   Control := New(PScrollBar, Init(R));
  842.   Insert(Control);
  843.   R.Assign(3,6,34,14);
  844.   FileList := New(PFileList, Init(R, PScrollBar(Control)));
  845.   Insert(FileList);
  846.   R.Assign(2,5,8,6);
  847.   Control := New(PLabel, Init(R, '~F~iles', FileList));
  848.   Insert(Control);
  849.  
  850.   R.Assign(35,3,46,5);
  851.   Opt := bfDefault;
  852.   if AOptions and fdOpenButton <> 0 then
  853.   begin
  854.     Insert(New(PButton, Init(R, '~O~pen', cmFileOpen, Opt)));
  855.     Opt := bfNormal;
  856.     Inc(R.A.Y,3); Inc(R.B.Y,3);
  857.   end;
  858.   if AOptions and fdOkButton <> 0 then
  859.   begin
  860.     Insert(New(PButton, Init(R, 'O~K~', cmFileOpen, Opt)));
  861.     Opt := bfNormal;
  862.     Inc(R.A.Y,3); Inc(R.B.Y,3);
  863.   end;
  864.   if AOptions and fdReplaceButton <> 0 then
  865.   begin
  866.     Insert(New(PButton, Init(R, '~R~eplace',cmFileReplace, Opt)));
  867.     Opt := bfNormal;
  868.     Inc(R.A.Y,3); Inc(R.B.Y,3);
  869.   end;
  870.   if AOptions and fdClearButton <> 0 then
  871.   begin
  872.     Insert(New(PButton, Init(R, '~C~lear',cmFileClear, Opt)));
  873.     Opt := bfNormal;
  874.     Inc(R.A.Y,3); Inc(R.B.Y,3);
  875.   end;
  876.   Insert(New(PButton, Init(R, 'Cancel', cmCancel, bfNormal)));
  877.   Inc(R.A.Y,3); Inc(R.B.Y,3);
  878.   if AOptions and fdHelpButton <> 0 then
  879.   begin
  880.     Insert(New(PButton, Init(R, 'Help',cmHelp, bfNormal)));
  881.     Inc(R.A.Y,3); Inc(R.B.Y,3);
  882.   end;
  883.  
  884.   R.Assign(1,16,48,18);
  885.   Control := New(PFileInfoPane, Init(R));
  886.   Insert(Control);
  887.  
  888.   SelectNext(False);
  889.  
  890.   if AOptions and fdNoLoadDir = 0 then ReadDirectory;
  891. end;
  892.  
  893. constructor TFileDialog.Load(var S: TStream);
  894. var
  895.   ACurDir: DirStr;
  896.   ViewId: Word;
  897. begin
  898.   TDialog.Load(S);
  899.   S.Read(WildCard, SizeOf(TWildStr));
  900.   GetSubViewPtr(S, FileName);
  901.   GetSubViewPtr(S, FileList);
  902.  
  903.   ReadDirectory;
  904. end;
  905.  
  906. destructor TFileDialog.Done;
  907. begin
  908.   DisposeStr(Directory);
  909.   TDialog.Done;
  910. end;
  911.  
  912. procedure TFileDialog.GetData(var Rec);
  913. begin
  914.   GetFilename(PathStr(Rec));
  915. end;
  916.  
  917. procedure TFileDialog.GetFileName(var S: PathStr);
  918. var
  919.   Path: PathStr;
  920.   Name: NameStr;
  921.   Ext: ExtStr;
  922.   TPath: PathStr;
  923.   TName: NameStr;
  924.   TExt: NameStr;
  925.  
  926. function LTrim(const S: String): String;
  927. var
  928.   I: Integer;
  929. begin
  930.   I := 1;
  931.   while (I < Length(S)) and (S[I] = ' ') do Inc(I);
  932.   LTrim := Copy(S, I, 255);
  933. end;
  934.  
  935. function RTrim(const S: String): String;
  936. var
  937.   I: Integer;
  938. begin
  939.   I := Length(S);
  940.   while S[I] = ' ' do Dec(I);
  941.   RTrim := Copy(S, 1, I);
  942. end;
  943.  
  944. function RelativePath(var S: PathStr): Boolean;
  945. begin
  946.   S := LTrim(RTrim(S));
  947.   RelativePath := not ((S <> '') and ((S[1] = '\') or (S[2] = ':')));
  948. end;
  949.  
  950. function NoWildChars(S: String): String; near; assembler;
  951. asm
  952.     PUSH    DS
  953.     LDS    SI,S
  954.         XOR     AX,AX
  955.     LODSB
  956.     XCHG    AX,CX
  957.         LES     DI,@Result
  958.         INC     DI
  959.         JCXZ    @@3
  960. @@1:    LODSB
  961.     CMP    AL,'?'
  962.     JE    @@2
  963.     CMP    AL,'*'
  964.     JE    @@2
  965.     STOSB
  966. @@2:    LOOP    @@1
  967. @@3:    XCHG    AX,DI
  968.     MOV    DI,WORD PTR @Result
  969.     SUB    AX,DI
  970.         DEC     AX
  971.         STOSB
  972.     POP    DS
  973. end;
  974.  
  975. begin
  976.   S := FileName^.Data^;
  977.   if RelativePath(S) then S := FExpand(Directory^ + S)
  978.   else S := FExpand(S);
  979.   FSplit(S, Path, Name, Ext);
  980.   if ((Name = '') or (Ext = '')) and not IsDir(S) then
  981.   begin
  982.     FSplit(WildCard, TPath, TName, TExt);
  983.     if ((Name = '') and (Ext = '')) then S := Path + TName + TExt
  984.     else if Name = '' then S := Path + TName + Ext
  985.     else if Ext = '' then
  986.     begin
  987.       if IsWild(Name) then S := Path + Name + TExt
  988.       else S := Path + Name + NoWildChars(TExt);
  989.     end;
  990.   end;
  991. end;
  992.  
  993. procedure TFileDialog.HandleEvent(var Event: TEvent);
  994. begin
  995.   TDialog.HandleEvent(Event);
  996.   if Event.What = evCommand then
  997.     case Event.Command of
  998.       cmFileOpen, cmFileReplace, cmFileClear:
  999.         begin
  1000.           EndModal(Event.Command);
  1001.           ClearEvent(Event);
  1002.         end;
  1003.     end;
  1004. end;
  1005.  
  1006. procedure TFileDialog.SetData(var Rec);
  1007. begin
  1008.   TDialog.SetData(Rec);
  1009.   if (PathStr(Rec) <> '') and (IsWild(TWildStr(Rec))) then
  1010.   begin
  1011.     Valid(cmFileInit);
  1012.     FileName^.Select;
  1013.   end;
  1014. end;
  1015.  
  1016. procedure TFileDialog.ReadDirectory;
  1017. begin
  1018.   FileList^.ReadDirectory(WildCard);
  1019.   Directory := NewStr(GetCurDir);
  1020. end;
  1021.  
  1022. procedure TFileDialog.Store(var S: TStream);
  1023. begin
  1024.   TDialog.Store(S);
  1025.   S.Write(WildCard, SizeOf(TWildStr));
  1026.   PutSubViewPtr(S, FileName);
  1027.   PutSubViewPtr(S, FileList);
  1028. end;
  1029.  
  1030. function TFileDialog.Valid(Command: Word): Boolean;
  1031. var
  1032.   T: Boolean;
  1033.   FName: PathStr;
  1034.   Dir: DirStr;
  1035.   Name: NameStr;
  1036.   Ext: ExtStr;
  1037.  
  1038. function CheckDirectory(var S: PathStr): Boolean;
  1039. begin
  1040.   if not PathValid(S) then
  1041.   begin
  1042.     MessageBox('Invalid drive or directory.', nil, mfError + mfOkButton);
  1043.     FileName^.Select;
  1044.     CheckDirectory := False;
  1045.   end else CheckDirectory := True;
  1046. end;
  1047.  
  1048. begin
  1049.   if Command = 0 then
  1050.   begin
  1051.     Valid := True;
  1052.     Exit;
  1053.   end else Valid := False;
  1054.   if TDialog.Valid(Command) then
  1055.   begin
  1056.     GetFileName(FName);
  1057.     if (Command <> cmCancel) and (Command <> cmFileClear) then
  1058.     begin
  1059.       if IsWild(FName) then
  1060.       begin
  1061.         FSplit(FName, Dir, Name, Ext);
  1062.         if CheckDirectory(Dir) then
  1063.         begin
  1064.           DisposeStr(Directory);
  1065.           Directory := NewStr(Dir);
  1066.           WildCard := Name+Ext;
  1067.           if Command <> cmFileInit then FileList^.Select;
  1068.           FileList^.ReadDirectory(Directory^+WildCard);
  1069.         end
  1070.       end
  1071.       else if IsDir(FName) then
  1072.       begin
  1073.         if CheckDirectory(FName) then
  1074.         begin
  1075.           DisposeStr(Directory);
  1076.       Directory := NewSTr(FName+'\');
  1077.       if Command <> cmFileInit then FileList^.Select;
  1078.       FileList^.ReadDirectory(Directory^+WildCard);
  1079.         end
  1080.       end else if ValidFileName(FName) then Valid := True
  1081.       else
  1082.       begin
  1083.         MessageBox('Invalid file name.', nil, mfError + mfOkButton);
  1084.         Valid := False;
  1085.       end
  1086.     end
  1087.     else Valid := True;
  1088.   end;
  1089. end;
  1090.  
  1091. { TDirCollection }
  1092.  
  1093. function TDirCollection.GetItem(var S: TStream): Pointer;
  1094. var
  1095.   DirItem: PDirEntry;
  1096. begin
  1097.   New(DirItem);
  1098.   DirItem^.DisplayText := S.ReadStr;
  1099.   DirItem^.Directory := S.ReadStr;
  1100.   GetItem := DirItem;
  1101. end;
  1102.  
  1103. procedure TDirCollection.FreeItem(Item: Pointer);
  1104. var
  1105.   DirItem: PDirEntry absolute Item;
  1106. begin
  1107.   DisposeStr(DirItem^.DisplayText);
  1108.   DisposeStr(DirItem^.Directory);
  1109.   Dispose(DirItem);
  1110. end;
  1111.  
  1112. procedure TDirCollection.PutItem(var S: TStream; Item: Pointer);
  1113. var
  1114.   DirItem: PDirEntry absolute Item;
  1115. begin
  1116.   S.WriteStr(DirItem^.DisplayText);
  1117.   S.WriteStr(DirItem^.Directory);
  1118. end;
  1119.  
  1120. { TDirListBox }
  1121.  
  1122. const
  1123.   DrivesS: String[6] = 'Drives';
  1124.   Drives: PString = @DrivesS;
  1125.  
  1126. constructor TDirListBox.Init(var Bounds: TRect; AScrollBar:
  1127.   PScrollBar);
  1128. begin
  1129.   TListBox.Init(Bounds, 1, AScrollBar);
  1130.   Dir := '';
  1131. end;
  1132.  
  1133. destructor TDirListBox.Done;
  1134. begin
  1135.   if List <> nil then Dispose(List, Done);
  1136.   TListBox.Done;
  1137. end;
  1138.  
  1139. function TDirListBox.GetText(Item: Integer; MaxLen: Integer): String;
  1140. begin
  1141.   GetText := PDirEntry(List^.At(Item))^.DisplayText^;
  1142. end;
  1143.  
  1144. procedure TDirListBox.HandleEvent(var Event: TEvent);
  1145. begin
  1146.   if (Event.What = evMouseDown) and (Event.Double) then
  1147.   begin
  1148.     Event.What := evCommand;
  1149.     Event.Command := cmChangeDir;
  1150.     PutEvent(Event);
  1151.     ClearEvent(Event);
  1152.   end
  1153.   else TListBox.HandleEvent(Event);
  1154. end;
  1155.  
  1156. function TDirListBox.IsSelected(Item: Integer): Boolean;
  1157. begin
  1158.   IsSelected := Item = Cur;
  1159. end;
  1160.  
  1161. procedure TDirListBox.NewDirectory(var ADir: DirStr);
  1162. const
  1163.   PathDir            = '└─┬';
  1164.   FirstDir           =   '└┬─';
  1165.   MiddleDir          =   ' ├─';
  1166.   LastDir            =   ' └─';
  1167.   IndentSize         = '  ';
  1168. var
  1169.   AList: PCollection;
  1170.   NewDir, Dirct: DirStr;
  1171.   C, OldC: Char;
  1172.   S, Indent: String[80];
  1173.   P: PString;
  1174.   isFirst: Boolean;
  1175.   SR: SearchRec;
  1176.   I: Integer;
  1177.   DirEntry: PDirEntry;
  1178.  
  1179. function NewDirEntry(const DisplayText, Directory: String): PDirEntry; near;
  1180. var
  1181.   DirEntry: PDirEntry;
  1182. begin
  1183.   New(DirEntry);
  1184.   DirEntry^.DisplayText := NewStr(DisplayText);
  1185.   DirEntry^.Directory := NewStr(Directory);
  1186.   NewDirEntry := DirEntry;
  1187. end;
  1188.  
  1189. function GetCurDrive: Char; near; assembler;
  1190. asm
  1191.     MOV    AH,19H
  1192.         INT    21H
  1193.         ADD    AL,'A'
  1194. end;
  1195.  
  1196. begin
  1197.   Dir := ADir;
  1198.   AList := New(PDirCollection, Init(5,5));
  1199.   AList^.Insert(NewDirEntry(Drives^,Drives^));
  1200.   if Dir = Drives^ then
  1201.   begin
  1202.     isFirst := True;
  1203.     OldC := ' ';
  1204.     for C := 'A' to 'Z' do
  1205.     begin
  1206.       if (C < 'C') or DriveValid(C) then
  1207.       begin
  1208.         if OldC <> ' ' then
  1209.     begin
  1210.           if isFirst then
  1211.       begin
  1212.         S := FirstDir + OldC;
  1213.             isFirst := False;
  1214.           end
  1215.           else S := MiddleDir + OldC;
  1216.       AList^.Insert(NewDirEntry(S, OldC + ':\'));
  1217.         end;
  1218.         if C = GetCurDrive then Cur := AList^.Count;
  1219.         OldC := C;
  1220.       end;
  1221.     end;
  1222.     if OldC <> ' ' then AList^.Insert(NewDirEntry(LastDir + OldC, OldC + ':\'));
  1223.   end
  1224.   else
  1225.   begin
  1226.     Indent := IndentSize;
  1227.     NewDir := Dir;
  1228.     Dirct := Copy(NewDir,1,3);
  1229.     AList^.Insert(NewDirEntry(PathDir + Dirct, Dirct));
  1230.     NewDir := Copy(NewDir,4,255);
  1231.     while NewDir <> '' do
  1232.     begin
  1233.       I := Pos('\',NewDir);
  1234.       if I <> 0 then
  1235.       begin
  1236.         S := Copy(NewDir,1,I-1);
  1237.         Dirct := Dirct + S;
  1238.         AList^.Insert(NewDirEntry(Indent + PathDir + S, Dirct));
  1239.         NewDir := Copy(NewDir,I+1,255);
  1240.       end
  1241.       else
  1242.       begin
  1243.         Dirct := Dirct + NewDir;
  1244.         AList^.Insert(NewDirEntry(Indent + PathDir + NewDir, Dirct));
  1245.         NewDir := '';
  1246.       end;
  1247.       Indent := Indent + IndentSize;
  1248.       Dirct := Dirct + '\';
  1249.     end;
  1250.     Cur := AList^.Count-1;
  1251.     isFirst := True;
  1252.     NewDir := Dirct + '*.*';
  1253.     FindFirst(NewDir, Directory, SR);
  1254.     while DosError = 0 do
  1255.     begin
  1256.       if (SR.Attr and Directory <> 0) and (SR.Name[1] <> '.') then
  1257.       begin
  1258.         if isFirst then
  1259.     begin
  1260.       S := FirstDir;
  1261.       isFirst := False;
  1262.     end else S := MiddleDir;
  1263.         AList^.Insert(NewDirEntry(Indent + S + SR.Name, Dirct + SR.Name));
  1264.       end;
  1265.       FindNext(SR);
  1266.     end;
  1267.     P := PDirEntry(AList^.At(AList^.Count-1))^.DisplayText;
  1268.     I := Pos('└',P^);
  1269.     if I = 0 then
  1270.     begin
  1271.       I := Pos('├',P^);
  1272.       if I <> 0 then P^[I] := '└';
  1273.     end else
  1274.     begin
  1275.       P^[I+1] := '─';
  1276.       P^[I+2] := '─';
  1277.     end;
  1278.   end;
  1279.   NewList(AList);
  1280.   FocusItem(Cur);
  1281. end;
  1282.  
  1283. procedure TDirListBox.SetState(AState: Word; Enable: Boolean);
  1284. begin
  1285.   TListBox.SetState(AState, Enable);
  1286.   if AState and sfFocused <> 0 then
  1287.     PChDirDialog(Owner)^.ChDirButton^.MakeDefault(Enable);
  1288. end;
  1289.  
  1290. { TChDirDialog }
  1291.  
  1292. constructor TChDirDialog.Init(AOptions: Word; HistoryId: Word);
  1293. var
  1294.   R: TRect;
  1295.   Control: PView;
  1296.   CurDir: DirStr;
  1297. begin
  1298.   R.Assign(16, 2, 64, 20);
  1299.   TDialog.Init(R, 'Change Directory');
  1300.  
  1301.   Options := Options or ofCentered;
  1302.  
  1303.   R.Assign(3, 3, 30, 4);
  1304.   DirInput := New(PInputLine, Init(R, 68));
  1305.   Insert(DirInput);
  1306.   R.Assign(2, 2, 17, 3);
  1307.   Control := New(PLabel, Init(R, 'Directory ~n~ame', DirInput));
  1308.   Insert(Control);
  1309.   R.Assign(30, 3, 33, 4);
  1310.   Control := New(PHistory, Init(R, DirInput, HistoryId));
  1311.   Insert(Control);
  1312.  
  1313.   R.Assign(32, 6, 33, 16);
  1314.   Control := New(PScrollBar, Init(R));
  1315.   Insert(Control);
  1316.   R.Assign(3, 6, 32, 16);
  1317.   DirList := New(PDirListBox, Init(R, PScrollBar(Control)));
  1318.   Insert(DirList);
  1319.   R.Assign(2, 5, 17, 6);
  1320.   Control := New(PLabel, Init(R, 'Directory ~t~ree', DirList));
  1321.   Insert(Control);
  1322.  
  1323.   R.Assign(35, 6, 45, 8);
  1324.   OkButton := New(PButton, Init(R, 'O~K~', cmOK, bfDefault));
  1325.   Insert(OkButton);
  1326.   Inc(R.A.Y,3); Inc(R.B.Y,3);
  1327.   ChDirButton := New(PButton, Init(R, '~C~hdir', cmChangeDir, bfNormal));
  1328.   Insert(ChDirButton);
  1329.   Inc(R.A.Y,3); Inc(R.B.Y,3);
  1330.   Insert(New(PButton, Init(R, '~R~evert', cmRevert, bfNormal)));
  1331.   if AOptions and cdHelpButton <> 0 then
  1332.   begin
  1333.     Inc(R.A.Y,3); Inc(R.B.Y,3);
  1334.     Insert(New(PButton, Init(R, 'Help', cmHelp, bfNormal)));
  1335.   end;
  1336.  
  1337.   if AOptions and cdNoLoadDir = 0 then SetUpDialog;
  1338.  
  1339.   SelectNext(False);
  1340. end;
  1341.  
  1342. constructor TChDirDialog.Load(var S: TStream);
  1343. var
  1344.   CurDir: DirStr;
  1345. begin
  1346.   TDialog.Load(S);
  1347.   GetSubViewPtr(S, DirList);
  1348.   GetSubViewPtr(S, DirInput);
  1349.   GetSubViewPtr(S, OkButton);
  1350.   GetSubViewPtr(S, ChDirbutton);
  1351.   SetUpDialog;
  1352. end;
  1353.  
  1354. function TChDirDialog.DataSize: Word;
  1355. begin
  1356.   DataSize := 0;
  1357. end;
  1358.  
  1359. procedure TChDirDialog.GetData(var Rec);
  1360. begin
  1361. end;
  1362.  
  1363. procedure TChDirDialog.HandleEvent(var Event: TEvent);
  1364. var
  1365.   CurDir: DirStr;
  1366.   P: PDirEntry;
  1367. begin
  1368.   TDialog.HandleEvent(Event);
  1369.   case Event.What of
  1370.     evCommand:
  1371.       begin
  1372.         case Event.Command of
  1373.           cmRevert: GetDir(0,CurDir);
  1374.           cmChangeDir:
  1375.             begin
  1376.               P := DirList^.List^.At(DirList^.Focused);
  1377.               if (P^.Directory^ = Drives^) or DriveValid(P^.Directory^[1]) then
  1378.                 CurDir := P^.Directory^
  1379.               else Exit;
  1380.             end;
  1381.         else
  1382.           Exit;
  1383.         end;
  1384.         if (Length(CurDir) > 3) and (CurDir[Length(CurDir)] = '\') then
  1385.           CurDir := Copy(CurDir,1,Length(CurDir)-1);
  1386.         DirList^.NewDirectory(CurDir);
  1387.         DirInput^.Data^ := CurDir;
  1388.         DirInput^.DrawView;
  1389.         DirList^.Select;
  1390.         ClearEvent(Event);
  1391.       end;
  1392.   end;
  1393. end;
  1394.  
  1395. procedure TChDirDialog.SetData(var Rec);
  1396. begin
  1397. end;
  1398.  
  1399. procedure TChDirDialog.SetUpDialog;
  1400. var
  1401.   CurDir: DirStr;
  1402. begin
  1403.   if DirList <> nil then
  1404.   begin
  1405.     CurDir := GetCurDir;
  1406.     DirList^.NewDirectory(CurDir);
  1407.     if (Length(CurDir) > 3) and (CurDir[Length(CurDir)] = '\') then
  1408.       CurDir := Copy(CurDir,1,Length(CurDir)-1);
  1409.     if DirInput <> nil then
  1410.     begin
  1411.       DirInput^.Data^ := CurDir;
  1412.       DirInput^.DrawView;
  1413.     end;
  1414.   end;
  1415. end;
  1416.  
  1417. procedure TChDirDialog.Store(var S: TStream);
  1418. begin
  1419.   TDialog.Store(S);
  1420.   PutSubViewPtr(S, DirList);
  1421.   PutSubViewPtr(S, DirInput);
  1422.   PutSubViewPtr(S, OkButton);
  1423.   PutSubViewPtr(S, ChDirButton);
  1424. end;
  1425.  
  1426. function TChDirDialog.Valid(Command: Word): Boolean;
  1427. var
  1428.   P: PathStr;
  1429. begin
  1430.   Valid := True;
  1431.   if Command = cmOk then
  1432.   begin
  1433.     P := FExpand(DirInput^.Data^);
  1434.     if (Length(P) > 3) and (P[Length(P)] = '\') then Dec(P[0]);
  1435.     {$I-}
  1436.     ChDir(P);
  1437.     if IOResult <> 0 then
  1438.     begin
  1439.       MessageBox('Invalid directory.', nil, mfError + mfOkButton);
  1440.       Valid := False;
  1441.     end;
  1442.     {$I+}
  1443.   end;
  1444. end;
  1445.  
  1446. procedure RegisterStdDlg;
  1447. begin
  1448.   RegisterType(RFileInputLine);
  1449.   RegisterType(RFileCollection);
  1450.   RegisterType(RFileList);
  1451.   RegisterType(RFileInfoPane);
  1452.   RegisterType(RFileDialog);
  1453.   RegisterType(RDirCollection);
  1454.   RegisterType(RDirListBox);
  1455.   RegisterType(RSortedListBox);
  1456.   RegisterType(RChDirDialog);
  1457. end;
  1458.  
  1459. end.
  1460.